home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 February: Tool Chest / Apple Developer CD Series Tool Chest February 1996 (Apple Computer)(1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / zebu v3.3.3 (LALR parser) / zebu-tree-attributes.lisp < prev   
Encoding:
Text File  |  1994-09-12  |  27.5 KB  |  791 lines  |  [TEXT/ttxt]
  1. ; -*- mode:     CL -*- ----------------------------------------------------- ;
  2. ; File:         zebu-tree-attributes.l
  3. ; Description:  Functions operating on abstract syntax trees
  4. ; Author:       Joachim H. Laubsch
  5. ; Created:      26-Feb-93
  6. ; Modified:     Tue Aug  2 17:11:32 1994 (Joachim H. Laubsch)
  7. ; Language:     CL
  8. ; Package:      ZEBU
  9. ; Status:       Experimental (Do Not Distribute) 
  10. ; RCS $Header: $
  11. ;
  12. ; (c) Copyright 1990, Hewlett-Packard Company
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14.  
  15. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  16. (in-package "ZEBU")
  17. (require "zebu-kb-domain")
  18. (provide "zebu-tree-attributes")
  19.  
  20. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  21. ;;                               tree attributes
  22. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  23. ;; Plist implementation
  24.  
  25. (declaim (inline KB-TREE-ATTRIBUTES))
  26. (defun KB-tree-attributes (class-name)
  27.   (get (the symbol class-name) 'KB-TREE-ATTRIBUTES))
  28. ;----------------------------------------------------------------------------;
  29. ; define-tree-attributes
  30. ;-----------------------
  31. ; for each class enter the tree attributes in the form:
  32. ; ((<reader1> <reader2> ...) .  (<writer1> <writer2> ...))
  33. ; where <readeri> is the name of the accessor for slot i
  34. ;       <writeri> is a compiled function to set slot i
  35.  
  36. (defun define-tree-attributes (class slots)
  37.   (let (writers)
  38.     (dolist (slot slots)
  39.       (let ((def `(lambda (x y)
  40.            (declare (type ,class x))
  41.            (setf (,slot x) y))))
  42.     (push
  43.      (compile nil def)
  44.            writers)))
  45.     (setf (get (the symbol class) 'KB-TREE-ATTRIBUTES)
  46.       (cons slots (nreverse writers))) ))
  47.  
  48. ;; The reason for this macro is that then the compiler does
  49. ;; not need to be loaded when a file is loaded which contains 
  50. ;; def-tree-attributes forms
  51. #||
  52. (defmacro def-tree-attributes (class &rest slots)
  53.   (check-type class symbol)
  54.   (let (writers setters)
  55.     (dolist (slot slots)
  56.       (check-type slot symbol)
  57.       (let* ((setter (intern (format nil "SET-~a" slot)))
  58.          (def `(defun ,setter (x y)
  59.             (declare (type ,class x))
  60.             (setf (,slot x) y))))
  61.     (push def writers)
  62.     (push setter setters)))
  63.     `(progn
  64.       ,@writers
  65.       (setf (get ',class 'KB-TREE-ATTRIBUTES)
  66.        (cons
  67.     ',slots
  68.     (mapcar #'(lambda (setter) (symbol-function setter))
  69.             ',(nreverse setters)))))))
  70. ||#
  71.  
  72. ;; avoid duplicate definitions
  73. (defmacro def-tree-attributes (class &rest slots)
  74.   (check-type class symbol)
  75.   (let (writers setters)
  76.     (dolist (slot slots)
  77.       (check-type slot symbol)
  78.       (let ((setter (intern (format nil "SET-~a" slot))))
  79.     (unless (fboundp setter)
  80.       (push `(defun ,setter (x y)
  81.           (declare (type ,class x))
  82.           (setf (,slot x) y))
  83.         writers))
  84.     (push setter setters)))
  85.     `(progn
  86.       (eval-when (compile eval) ,@writers)
  87.       (setf (get ',class 'KB-TREE-ATTRIBUTES)
  88.        (cons
  89.     ',slots
  90.     (mapcar #'(lambda (setter) (symbol-function setter))
  91.         ',(nreverse setters)))))))
  92.  
  93. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  94. ;; Hashtable implementation 
  95. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  96. #||
  97. (defvar *KB-TREE-ATTRIBUTES* (make-hash-table))
  98. (declaim (type HASH-TABLE *KB-TREE-ATTRIBUTES*))
  99.  
  100. (declaim (inline KB-TREE-ATTRIBUTES))
  101. (defun KB-TREE-ATTRIBUTES (class-name)
  102.   (gethash class-name *KB-TREE-ATTRIBUTES*))
  103.  
  104. ;----------------------------------------------------------------------------;
  105. ; define-tree-attributes
  106. ;-----------------------
  107. ; for each class enter the tree attributes in the form:
  108. ; ((<reader1> <reader2> ...) .  (<writer1> <writer2> ...))
  109. ; where <readeri> is the name of the accessor for slot i
  110. ;       <writeri> is a compiled function to set slot i
  111.  
  112. (declaim (inline KB-TREE-ATTRIBUTES))
  113. (defun define-tree-attributes (class slots)
  114.   (let (writers)
  115.     (dolist (slot slots)
  116.       (let ((def `(lambda (x y)
  117.            (declare (type ,class x))
  118.            (setf (,slot x) y))))
  119.     (push 
  120.      (compile nil def)
  121.      writers)))
  122.     (setf (gethash class *KB-TREE-ATTRIBUTES*)
  123.       (cons slots (nreverse writers))) ))
  124. ||#
  125.  
  126. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  127. ;;                              Set/Sequence Valued Slots
  128. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  129.  
  130. (defvar *KB-SLOT-types* (make-hash-table))
  131. (declaim (type HASH-TABLE *KB-SLOT-types*))
  132.  
  133. (declaim (inline KB-set-valued-slot-p))
  134. (defun KB-set-valued-slot-p (reader)
  135.   (eq (gethash reader *KB-SLOT-types*) ':set))
  136.  
  137. (defun KB-def-slot-type (reader type)
  138.   (setf (gethash reader *KB-SLOT-types*) type))
  139.  
  140.  
  141. ;----------------------------------------------------------------------------;
  142. ; kids
  143. ;-----
  144. ; collect all the kids of OBJECT which are in KB-Domain.
  145. ; if a kid is a SET or SEQUENCE of subnodes, include those which are
  146. ; in KB-Domain.
  147.  
  148. (defun kids (object &aux R)
  149.   (declare (inline KB-TREE-ATTRIBUTES))
  150.   (macrolet ((readers (x) `(the list (car (the cons ,x)))))
  151.     (let ((ta (KB-tree-attributes (type-of object))))
  152.       (when ta
  153.     (dolist (reader (readers ta) R)
  154.       (declare (symbol reader))
  155.       (let ((kids (funcall (the function (symbol-function reader)) object)))
  156.         (cond ((consp kids)
  157.            (dolist (k (the list kids))
  158.              (when (KB-Domain-p k) (push k R))))
  159.           ((KB-Domain-p kids)
  160.            (push kids R))))))))
  161.   )
  162.  
  163. ;-----------------------------------------------------------------------------;
  164. ; subexpressions
  165. ;---------------
  166. ; 
  167. ; All immediate subexpressions of a KB-Domain-element
  168. ; anything not of type KB-Domain-element does not have components
  169.  
  170. (declaim (inline subexpressions))
  171. (defun subexpressions (KB-Domain-element)
  172.   (check-type KB-Domain-element KB-Domain)
  173.   (kids KB-Domain-element))
  174.  
  175. ;----------------------------------------------------------------------------;
  176. ; for-each-kid
  177. ;-------------
  178. ; iterate over all kids of NODE which are in KB-Domain, calling FUN.
  179. ; NODE must be of type KB-Domain.
  180. ; Returns nil
  181.  
  182. (defun for-each-kid (FUN NODE)
  183.   (declare (type function fun))
  184.   (macrolet ((readers (x) `(the list (car (the cons ,x)))))
  185.     (if (KB-Domain-p NODE)        ;  (subtypep typ 'KB-Domain)
  186.     (let ((ta (KB-tree-attributes (type-of node))))
  187.       (when ta
  188.         (dolist (reader (readers ta))
  189.           (declare (symbol reader))
  190.           (let ((subnode (funcall (the function (symbol-function reader)) NODE)))
  191.         (cond
  192.           ((CONSp subnode)    ; value is a set or sequence
  193.            (dolist (kid (the list subnode))
  194.              (when (KB-Domain-p kid) (funcall FUN kid))))
  195.           ((KB-Domain-p subnode) (funcall fun subnode)))))))
  196.       (error "Can't iterate over non KB-Domain object: ~S" NODE))))
  197.  
  198. (defun for-each-kid! (FUN NODE)
  199.   ;; just like for-each-kid, but if FUN(kid) ~eq kid then replace kid
  200.   ;; by the value of FUN(kid)
  201.   ;; returns NODE
  202.   (declare (type function fun))
  203.   (declare (inline KB-TREE-ATTRIBUTES))
  204.   (if (KB-Domain-p NODE)        ;  (subtypep typ 'KB-Domain)
  205.       (macrolet ((readers (x) `(the list (car (the cons ,x))))
  206.          (writers (x) `(the list (cdr (the cons ,x)))))
  207.     (let ((ta (KB-tree-attributes (type-of node))))
  208.       (if (null ta)
  209.           NODE
  210.         ;; ta ((<reader1> <reader2> ...) (<writer1> <writer2> ...))
  211.         (do ((r (readers ta) (cdr r)) (w (writers ta) (cdr w)))
  212.         ((null r) NODE)
  213.           (let* ((reader (car (the cons r)))
  214.              (subnode (funcall (the function (symbol-function reader))
  215.                        NODE)))
  216.         (cond
  217.           ((CONSp subnode)    ; value is a set or sequence
  218.            (do ((kids (the list subnode) (cdr kids)))
  219.                ((null kids))
  220.              (let ((kid (car (the cons kids))))
  221.                (if (KB-Domain-p kid)
  222.                (let ((newval (funcall FUN kid)))
  223.                  (unless (eq kid newval)
  224.                    (setf (car kids) newval)))))))
  225.           ((KB-Domain-p subnode)
  226.            (let ((vv (funcall fun subnode)))
  227.              (unless (eq vv subnode)
  228.                ;; (eval `(setf (,reader ,NODE) ',vv))
  229.                (funcall (the compiled-function (car w)) NODE vv))))))))))
  230.     (error "Can't iterate over non KB-Domain object: ~S" NODE)))
  231.  
  232. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  233. ;;                             preorder-transform
  234. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  235. #||
  236. (defun preorder-transform (node funs)
  237.   (check-type node KB-Domain)
  238.   (check-type funs list)
  239.   (macrolet ((readers (x) `(the list (car (the cons ,x))))
  240.          (writers (x) `(the list (cdr (the cons ,x))))
  241.          (mung-node (n) `(preorder-transform-aux (transform-node ,n))))
  242.     (labels ((preorder-transform-aux (n)
  243.            (let ((ta (KB-tree-attributes (type-of n))))
  244.          (when (null ta)
  245.            (return-from preorder-transform-aux n))
  246.          (do ((r (readers ta) (cdr r)) (w (writers ta) (cdr w)))
  247.              ((null r) n)
  248.            (let* ((reader (car (the cons r)))
  249.               (subnode (funcall (the function (symbol-function reader))
  250.                         n)))
  251.              (cond ((CONSp subnode) ; value is a set or sequence
  252.                 (do ((kids (the list subnode) (cdr kids)))
  253.                 ((null kids))
  254.                   (let ((kid (car (the cons kids))))
  255.                 (when (KB-Domain-p kid)
  256.                   (let ((newval (mung-node kid)))
  257.                     (unless (eq kid newval)
  258.                       (setf (car (the cons kids)) newval)))))))
  259.                ((KB-Domain-p subnode)
  260.                 (let ((subnode1 (mung-node subnode)))
  261.                   (unless (eq subnode1 subnode)
  262.                 (funcall (car (the cons w)) n subnode1)))))))))
  263.          (transform-node (n)
  264.            (let (fun-fired?)
  265.          (do ((funRest (the list funs))
  266.               (oldn (KB-copy n) (KB-copy n))
  267.               )
  268.              ((null funRest) n)
  269.            (let ((fun (car funRest)))
  270.              ;; run each function to acquiescence
  271.              ;; each function returns 2 values, 
  272.              ;; (1) the new node
  273.              ;; (2) whether there was a change in this node
  274.              ;;     that may make it necessary for this function to run
  275.              ;;     again on the same node
  276.              ;; if a function had an effect --- fun-fired? = T  ---
  277.              ;; we start all over with all functions (except the current)
  278.              (loop do (multiple-value-bind (v change?)
  279.                   (funcall (the Function fun) n)
  280.                 (if change?
  281.                     (setq n v)
  282.                   (if (eq n v)
  283.                       (return n)
  284.                     (setq n v)))
  285.                 (format t "~%;; ~S~%;; ~S~%;; --> ~S" fun oldn v)
  286.                 (setq fun-fired? t)))
  287.              (if fun-fired?
  288.              (setq funRest (remove fun funs)
  289.                    fun-fired? nil)
  290.                (pop funRest)))))))
  291.       (mung-node node))))
  292. ||#
  293. (defun preorder-transform (node funs)
  294.   (declare (inline KB-TREE-ATTRIBUTES))
  295.   (check-type node KB-Domain) (check-type funs list)
  296.   (macrolet ((readers (x) `(the list (car (the cons ,x))))
  297.          (writers (x) `(the list (cdr (the cons ,x))))
  298.          (mung-node (n) `(preorder-transform-aux (transform-node ,n))))
  299.     (flet ((transform-node (n)
  300.          (let (fun-fired?)
  301.            (do ((funRest (the list funs)))
  302.            ((null funRest) n)
  303.          (let ((fun (car funRest)))
  304.            ;; run each function to acquiescence
  305.            ;; each function returns 2 values, 
  306.            ;; (1) the new node
  307.            ;; (2) whether there was a change in this node
  308.            ;;     that may make it necessary for this function to run
  309.            ;;     again on the same node
  310.            ;; if a function had an effect --- fun-fired? = T  ---
  311.            ;; we start all over with all functions (except the current)
  312.            (loop (multiple-value-bind (v change?)
  313.                  (funcall (the Function fun) n)
  314.                (if change?
  315.                    (setq n v)
  316.                  (if (eq n v)
  317.                  (return n)
  318.                    (setq n v)))
  319.                ;; (format t "~%;; ~S~%;; ~S~%;; --> ~S" fun oldn v)
  320.                (setq fun-fired? t)))
  321.            (if fun-fired?
  322.                (setq funRest (remove fun funs)
  323.                  fun-fired? nil)
  324.              (pop funRest)))))))
  325.       (labels ((preorder-transform-aux (n)
  326.          (let ((ta (KB-tree-attributes (type-of n))))
  327.            (when (null ta)
  328.              (return-from preorder-transform-aux n))
  329.            (do ((r (readers ta) (cdr r)) (w (writers ta) (cdr w)))
  330.                ((null r) n)
  331.              (let* ((reader (car (the cons r)))
  332.                 (subnode (funcall (the function
  333.                            (symbol-function reader))
  334.                           n)))
  335.                (cond ((CONSp subnode) ; value is a set or sequence
  336.                   (do ((kids (the list subnode) (cdr kids)))
  337.                   ((null kids))
  338.                 (let ((kid (car (the cons kids))))
  339.                   (when (KB-Domain-p kid)
  340.                     (let ((newval (mung-node kid)))
  341.                       (unless (eq kid newval)
  342.                     (setf (car (the cons kids)) newval)))))))
  343.                  ((KB-Domain-p subnode)
  344.                   (let ((subnode1 (mung-node subnode)))
  345.                 (unless (eq subnode1 subnode)
  346.                   (funcall (car (the cons w)) n subnode1))))))))))
  347.     (mung-node node)))))
  348.  
  349. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  350. ;;                             postorder-transform
  351. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  352. ;; just like preorder, but descend down first to the leaves, and then
  353. ;; transform from bottom-up
  354. (defun postorder-transform (node funs &optional (exhaustive nil))
  355.   (declare (inline KB-TREE-ATTRIBUTES))
  356.   (check-type node KB-Domain) (check-type funs list)
  357.   (macrolet ((readers (x) `(the list (car (the cons ,x))))
  358.          (writers (x) `(the list (cdr (the cons ,x))))
  359.          ;; here is the difference to preorder: recurse first!
  360.          (mung-node (n)
  361.            `(transform-node (postorder-transform-aux ,n))))
  362.     (flet ((transform-node (n)
  363.          ;; (format t "~%transform-node: ~S" n)
  364.          (do ((funRest (the list funs)) rule-fired?)
  365.          ((null funRest) n)
  366.            (let ((fun (car funRest)))
  367.          ;; run each function to acquiescence
  368.          ;; each function returns 2 values, 
  369.          ;; (1) the new node
  370.          ;; (2) whether there was a change in this node
  371.          ;;     that may make it necessary for this function to run
  372.          ;;     again on the same node
  373.          ;; if a function had an effect --- fun-fired? = T  ---
  374.          ;; we start all over at the leaves
  375.          (loop (multiple-value-bind (v change?)
  376.                (funcall (the Function fun) n)
  377.              (if change?
  378.                  (setq n v)
  379.                (if (eq n v)
  380.                    (return nil)
  381.                  (setq n v)))
  382.              (if exhaustive
  383.                  (return-from transform-node
  384.                    (values n t))
  385.                (setq rule-fired? t))))
  386.          (if rule-fired?
  387.              (setq funRest (remove fun funs)
  388.                rule-fired? nil)
  389.            (pop funRest)))))) 
  390.       (labels ((postorder-transform-aux (n)
  391.          (let ((ta (KB-tree-attributes (type-of n))))
  392.            (when (null ta)
  393.              (return-from postorder-transform-aux n))
  394.            ; (format t "~%postorder-transform: ~S" n)
  395.            (do ((r (readers ta) (cdr r)) (w (writers ta) (cdr w)))
  396.                ((null r) n)
  397.              (let* ((reader (car (the cons r)))
  398.                 (subnode (funcall (the function
  399.                            (symbol-function reader))
  400.                           n)))
  401.                (cond ((CONSp subnode) ; value is a set or sequence
  402.                   (do ((kids (the list subnode) (cdr kids)))
  403.                   ((null kids))
  404.                 (let ((kid (car (the cons kids))))
  405.                   (when (KB-Domain-p kid)
  406.                     (loop
  407.                      (multiple-value-bind (newval rule-fired?)
  408.                      (mung-node kid)
  409.                        (if (eq kid newval)
  410.                        (if rule-fired?
  411.                            (if exhaustive
  412.                            nil  ; go on
  413.                          (return nil))
  414.                          (return nil))
  415.                      (progn
  416.                        (setf (car (the cons kids)) newval)
  417.                        (setf kid newval)
  418.                        (if exhaustive
  419.                            nil     ; go on
  420.                          (return nil))))))))))
  421.                  ((KB-Domain-p subnode)
  422.                   (loop
  423.                    (multiple-value-bind (subnode1 rule-fired?)
  424.                    (mung-node subnode)
  425.                  (if (eq subnode1 subnode)
  426.                      (if rule-fired?
  427.                      (if exhaustive
  428.                          nil ; go on
  429.                        (return nil))
  430.                        (return nil))
  431.                    (progn
  432.                      (funcall (car (the cons w)) n subnode1)
  433.                      (setf subnode subnode1)
  434.                      (if exhaustive
  435.                      nil ; go on
  436.                        (return nil)))))))))))))
  437.     (loop (multiple-value-bind (new rule-fired?)
  438.           (mung-node node)
  439.         (if exhaustive
  440.             (if (or rule-fired? (not (eq new node)))
  441.             (setq node new)
  442.               (return new))
  443.           (return new))))))))
  444.  
  445. #||
  446. (defun descendants (object)
  447.   (let ((R (list object)))
  448.     (dolist (kid (kids object) R)
  449.       (nconc R (descendants kid)))))
  450. ||#
  451. ;; more efficiently:
  452.  
  453. ;----------------------------------------------------------------------------;
  454. ; descendants
  455. ;------------
  456. ; 
  457.  
  458. (defun descendants (object &aux R)
  459.   (declare (inline KB-TREE-ATTRIBUTES))
  460.   (check-type object KB-Domain)    
  461.   (macrolet ((readers (x) `(the list (car (the cons ,x)))))  
  462.     (labels ((descendants-aux (object)
  463.            (let ((ta (KB-tree-attributes (type-of object))))
  464.          (when ta
  465.            (dolist (reader (readers ta))
  466.              (declare (symbol reader))
  467.              (let ((kids (funcall (the function (symbol-function reader))
  468.                       object)))
  469.                (cond ((consp kids)
  470.                   (dolist (k (the list kids))
  471.                 (push k R)
  472.                 (descendants-aux k)))
  473.                  ((KB-Domain-p kids)
  474.                   (push kids R)
  475.                   (descendants-aux kids)))))))))
  476.       (descendants-aux object)
  477.       (nreverse (cons object R)))))
  478.  
  479. ;----------------------------------------------------------------------------;
  480. ; for-each-descendant
  481. ;--------------------
  482. ; like for-each-kid
  483. ; Returns nil
  484.  
  485. (defun for-each-descendant (fn object)
  486.   (declare (type function fn))
  487.   (check-type object KB-Domain) 
  488.   (macrolet ((readers (x) `(the list (car (the cons ,x)))))  
  489.     (labels ((descendants-aux (object)
  490.            (let ((ta (KB-tree-attributes (type-of object))))
  491.          (when ta
  492.            (dolist (reader (readers ta))
  493.              (declare (symbol reader))
  494.              (let ((kids (funcall (the function (symbol-function reader))
  495.                       object)))
  496.                (cond ((consp kids)
  497.                   (dolist (k (the list kids))
  498.                 (funcall fn k)
  499.                 (descendants-aux k)))
  500.                  ((KB-Domain-p kids)
  501.                   (funcall fn kids)
  502.                   (descendants-aux kids)))))))))
  503.       (funcall fn object)
  504.       (descendants-aux object))))
  505.  
  506. ;----------------------------------------------------------------------------;
  507. ; KB-copy
  508. ;--------
  509. ; A copy function that walks down all the tree-attributes and copies
  510. ; unless called with :recursive-p Nil
  511.  
  512. #+LUCID
  513. (defmacro %copy-structure (x)
  514.     `(SYSTEM:copy-structure ,x))
  515.  
  516. #-LUCID
  517. (defun %copy-structure (term)
  518.   (let* ((ttype (type-of term))
  519.      (copy-fn (find-symbol (concatenate 
  520.                 'string "COPY-" (symbol-name ttype))
  521.                    (symbol-package ttype))))
  522.     (if (fboundp copy-fn)
  523.     (funcall copy-fn term)
  524.       (error "No COPY function defined for ~s:~a" term ttype)))) 
  525.  
  526. (defun KB-copy (term &optional (recursive-p t))
  527.   (declare (inline KB-TREE-ATTRIBUTES))
  528.   (macrolet ((readers (x) `(the list (car (the cons ,x))))
  529.          (writers (x) `(the list (cdr (the cons ,x)))))
  530.     (labels ((KB-copy-aux (term)
  531.            (declare (type KB-Domain term))
  532.            (let ((new-term (%COPY-STRUCTURE term))
  533.              (ta (KB-tree-attributes (type-of term))))
  534.          (if (null ta)
  535.              new-term
  536.            (do ((r (readers ta) (cdr r)) (w (writers ta) (cdr w)))
  537.                ((null r) new-term)
  538.              (let* ((reader (car (the cons r)))
  539.                 (writer (car (the cons w)))
  540.                 (subnode (funcall (the function
  541.                            (symbol-function
  542.                             (the symbol reader)))
  543.                           new-term)))
  544.                (cond ((CONSp subnode) ; value is a set or sequence 
  545.                   (let ((newsubnode
  546.                      (copy-list (the list subnode))))
  547.                 (funcall (the compiled-function writer)
  548.                      new-term newsubnode)
  549.                 (do ((nrest newsubnode (cdr nrest)))
  550.                     ((null nrest))
  551.                   (let ((kid (car (the cons nrest))))
  552.                     (when (KB-Domain-p kid)
  553.                       (setf (car (the cons nrest))
  554.                         (KB-copy-aux kid)))))))
  555.                  ((KB-Domain-p subnode)
  556.                   (funcall (the compiled-function writer)
  557.                        new-term
  558.                        (KB-copy-aux subnode))))))))))
  559.       (if recursive-p
  560.       (KB-copy-aux term)
  561.     (%COPY-STRUCTURE term)))))
  562.  
  563. #||
  564. ;; test
  565. (setq $a (eval (READ-PARSER "walk(agt : John ) ")))
  566. (setq $aa (KB-copy $a))
  567. ;;
  568. (car (KB-tree-attributes (type-of $a)))
  569. ;; (ATOMIC-WFF--PREDICATE ATOMIC-WFF--ROLE-ARGUMENT-PAIRS)
  570. (eq (ATOMIC-WFF--PREDICATE $a) (ATOMIC-WFF--PREDICATE $aa)) ; NIL
  571. (equal (ATOMIC-WFF--PREDICATE $a) (ATOMIC-WFF--PREDICATE $aa)) ; Nil
  572. (kb-equal (ATOMIC-WFF--PREDICATE $a)  (ATOMIC-WFF--PREDICATE $aa)) ; T
  573. ;; note: equalp does recursive descent on structures
  574. (equalp (ATOMIC-WFF--PREDICATE $a) (ATOMIC-WFF--PREDICATE $aa))    ; T
  575.  
  576. (setq $b (eval (READ-PARSER "and{walk(agent: John) talk(agent: John)}")))
  577. (type-of $b)
  578. (car (KB-tree-attributes (type-of $b)))
  579. (setq $bb  (KB-copy $b))
  580.  
  581. ||#
  582.  
  583. ;----------------------------------------------------------------------------;
  584. ; KB-equal
  585. ;----------
  586. ; compares 2 objects of the KB-domain for equality. (something like term-equal?)
  587. ;  considers only tree-attributes as relevant
  588. ;  This is easier to extend for set-valued slots:
  589.  
  590. (defun KB-equalp (a b)
  591.   (declare (inline KB-TREE-ATTRIBUTES))
  592.   (check-type a KB-domain)
  593.   (check-type b KB-domain)
  594.   ;; ignores implementation of constants
  595.   (macrolet ((readers (x) `(the list (car (the cons ,x)))))
  596.     (labels ((KB-equal-aux (a b)
  597.            (let ((a-typ (type-of a)) (b-typ (type-of b)))
  598.          (unless (equal a-typ b-typ) (return-from KB-equal-aux 'Nil))
  599.          (let ((ta (KB-tree-attributes a-typ)))
  600.            (or
  601.             (null ta)
  602.             (dolist (reader (readers ta) t)
  603.               (declare (symbol reader))
  604.               (let* ((reader-fn (symbol-function reader))
  605.                  (a-subnode (funcall reader-fn a))
  606.                  (b-subnode (funcall reader-fn b)))
  607.             (unless (eq a-subnode b-subnode)
  608.               (unless (equal (type-of a-subnode) (type-of b-subnode))
  609.                 (return-from KB-equal-aux 'Nil))
  610.               (cond
  611.                 ((CONSp a-subnode) ; value is a set or sequence
  612.                  (if (= (the fixnum (length (the list a-subnode)))
  613.                     (the fixnum (length (the list b-subnode))))
  614.                  (if (KB-set-valued-slot-p reader)
  615.                      ;; We have 2 sets to compare
  616.                      ;; resort to this to avoid consing, see
  617.                      ;; comment below:
  618.                      (unless
  619.                      (and (dolist (bb (the list b-subnode) t)
  620.                         (unless (dolist (aa (the list a-subnode))
  621.                               (when (KB-equal-aux aa bb)
  622.                                 (return t)))
  623.                           (return nil)))
  624.                           (dolist (aa (the list a-subnode) t)
  625.                         (unless (dolist (bb (the list b-subnode))
  626.                               (when (KB-equal-aux aa bb)
  627.                                 (return t)))
  628.                           (return nil))))
  629.                        (return-from KB-equal-aux 'Nil))
  630.                    ;; We have two sequences to compare
  631.                    ;; Their elements must be in KB-domain
  632.                    (do ((arest a-subnode (cdr arest))
  633.                     (brest b-subnode (cdr brest)))
  634.                        ((atom arest) (eq arest brest))
  635.                      (let ((aa (car (the cons arest)))
  636.                        (bb (car (the cons brest))))
  637.                        (unless (KB-equal-aux aa bb)
  638.                      (return-from KB-equal-aux 'Nil)))))
  639.                    (return-from KB-equal-aux 'Nil)))
  640.                 ((KB-domain-p a-subnode)
  641.                  (unless (KB-equal-aux a-subnode b-subnode)
  642.                    (return-from KB-equal-aux 'Nil)))
  643.                 ((symbolp a-subnode)
  644.                  (unless (string-equal (symbol-name a-subnode)
  645.                            (symbol-name b-subnode))
  646.                    (return-from KB-equal-aux 'Nil)))
  647.                 (T (unless (equal a-subnode b-subnode)
  648.                  (return-from KB-equal-aux 'Nil))))))))))))
  649.       (or (eq a b)
  650.       (KB-equal-aux a b)))))
  651.  
  652. #||
  653. (KB-equalp (read-nll "DESKTOP-OBJECT(NAME: 'Orders--STR')")
  654.         (read-nll "DESKTOP-OBJECT(NAME: Orders--STR)"))
  655. (KB-equalp (read-nll "WORK(agent:+{'ABRAMS','BROWNE'})")
  656.         (read-nll "WORK(agent:+{ABRAMS,BROWNE})"))
  657. (compile 'KB-equalp)
  658. ||#
  659. (defun KB-equal (a b &optional verbose)
  660.   (declare (inline KB-TREE-ATTRIBUTES))
  661.   (macrolet ((readers (x) `(the list (car (the cons ,x)))))
  662.     (labels
  663.       ((KB-equal-aux (a b)
  664.      (let ((a-typ (type-of a)) (b-typ (type-of b)))
  665.        ;; (break "~S:~s = ~S:~s" a a-typ b b-typ)
  666.        (unless (equal a-typ b-typ) (return-from KB-equal-aux 'Nil))
  667.        (if (typep a 'KB-domain)
  668.            (let ((ta (KB-tree-attributes a-typ)))
  669.          (or
  670.           (null ta)
  671.           (dolist (reader (readers ta) t)
  672.             (declare (symbol reader))
  673.             (let* ((reader-fn (symbol-function reader))
  674.                (a-subnode (funcall reader-fn a))
  675.                (b-subnode (funcall reader-fn b)))
  676.               (when verbose
  677.             (format t "~% KB-compare ~S:~S ~%           = ~S:~S"
  678.                 a-subnode (type-of a-subnode)
  679.                 b-subnode (type-of b-subnode)))
  680.               (unless (eq a-subnode b-subnode)
  681.             (unless (equal (type-of a-subnode) (type-of b-subnode))
  682.               (return-from KB-equal-aux 'Nil))
  683.             (cond
  684.               ((CONSp a-subnode) ; value is a set or sequence
  685.                (if (= (the fixnum (length (the list a-subnode)))
  686.                   (the fixnum (length (the list b-subnode))))
  687.                    (if (KB-set-valued-slot-p reader)
  688.                    ;; We have 2 sets to compare
  689.                    ;; resort to this to avoid consing, see
  690.                    ;; comment below:
  691.                    (unless
  692.                        (and (dolist (bb (the list b-subnode) t)
  693.                           (unless (dolist (aa (the list a-subnode))
  694.                             (when (KB-equal-aux aa bb)
  695.                               (return t)))
  696.                         (return nil)))
  697.                         (dolist (aa (the list a-subnode) t)
  698.                           (unless (dolist (bb (the list b-subnode))
  699.                             (when (KB-equal-aux aa bb)
  700.                               (return t)))
  701.                         (return nil))))
  702.                      (return-from KB-equal-aux 'Nil))
  703.                  ;; We have two sequences to compare
  704.                  ;; Their elements must be in KB-domain
  705.                  (do ((arest a-subnode (cdr arest))
  706.                       (brest b-subnode (cdr brest)))
  707.                      ((atom arest) (eq arest brest))
  708.                    (let ((aa (car (the cons arest)))
  709.                      (bb (car (the cons brest))))
  710.                      (or (equal aa bb)
  711.                      (KB-equal-aux aa bb)
  712.                      (return-from KB-equal-aux 'Nil)))))
  713.                  (return-from KB-equal-aux 'Nil)))
  714.               ((KB-domain-p a-subnode)
  715.                (unless (KB-equal-aux a-subnode b-subnode)
  716.                  (return-from KB-equal-aux 'Nil)))
  717.               ((symbolp a-subnode)
  718.                (unless (string= (symbol-name a-subnode)
  719.                         (symbol-name b-subnode))
  720.                  (return-from KB-equal-aux 'Nil)))
  721.               (T (unless (equal a-subnode b-subnode)
  722.                    (return-from KB-equal-aux 'Nil)))))))))
  723.          (equal a b)))))
  724.       (or (eq a b)
  725.       (KB-equal-aux a b)))))
  726.  
  727. #|| test
  728. (KB-equal (make-Placeholder-Var :-Name 'u486)
  729.       (make-Placeholder-Var :-Name 'subject-nl-semantics))
  730. ||#
  731.  
  732. ;; the following is useful for testing
  733. (defun KB-compare (a b &optional verbose)
  734.   (check-type a KB-domain)
  735.   (check-type b KB-domain)
  736.   (KB-equal a b verbose))
  737.  
  738. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  739. ;;                       tree-attributes for kb-sequence
  740. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  741. (def-tree-attributes kb-sequence
  742.     kb-sequence-first kb-sequence-rest)
  743.  
  744. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  745. ;;; Generate (define-tree-attributes ..) for zebu
  746. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  747. ; Das nachfolgende kannst Du zur Generierung der Tree-Attributes
  748. ; verwenden. Prepare-Tree-Attributes kann auch zur Laufzeit die
  749. ; Attribute eintragen; wenn Du die Definitionen ins Domainfile
  750. ; uebernimmst, muesste Zebu define-tree-attributes immer kennen
  751. ; (zebu-kernel?).
  752.  
  753. ;; diese hashtable ist fuer zebra wiederverwenbar (der gruene punkt)
  754.  
  755. (defparameter *local-accessor-hashtable* (make-hash-table :test #'equal))
  756.  
  757. (defun labelnode2accessor (label topnode)
  758.   "Translates a label symbol and its topnode
  759.    into a structure accessor (-predicate atomic-wff -> at-wff--pred)"
  760.   (let* ((key (cons label topnode))
  761.          (constr (gethash key *local-accessor-hashtable*)))
  762.     (if constr
  763.     constr
  764.       (setf (gethash key *local-accessor-hashtable*)
  765.         (intern (concatenate 'string 
  766.                  (symbol-name topnode) "-"
  767.                  (symbol-name label)))))))
  768.  
  769. (defun prepare-tree-attributes (type &optional (output-only nil) (stream T))
  770.   "sets kb-tree-attributes of type and all of its subtypes"
  771.   (let ((slots (kb-slots type))
  772.         (slot-funs nil))
  773.     (dolist (item slots)
  774.       (if (symbolp item)
  775.           (push (labelnode2accessor item type) slot-funs)
  776.         ;; else
  777.         (push (labelnode2accessor (first item) type) slot-funs)))
  778.     (when slot-funs
  779.       (setq slot-funs (nreverse slot-funs))
  780.       (if output-only
  781.           (format stream "~S~%~%" 
  782.                   `(define-tree-attributes ',type '(,@slot-funs)))
  783.         ;; else
  784.         (define-tree-attributes type slot-funs)))
  785.     (dolist (item (kb-subtypes type))
  786.       (prepare-tree-attributes item output-only stream))))
  787.  
  788. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  789. ;;                     End of zebu-tree-attributes.lisp
  790. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  791.